home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Oberon / OberonV4 / loader / OLoadData.Mod < prev    next >
Text File  |  1995-04-15  |  14KB  |  499 lines
  1. IMPLEMENTATION MODULE OLoadData;
  2. (*
  3.  This module allows the access to the data structures Module and
  4.  TypeDescriptor, which are used also in the Oberon System.
  5.  
  6.  The access is done through procedures. These procedures are
  7.  written in concordance to the aligning rules of the oberon
  8.  compiler.
  9.  
  10.  Thus this module has to be revised whenever the oberon compiler
  11.  is changed.
  12. *)
  13.  
  14. FROM SYSTEM IMPORT ADDRESS,CAST;
  15.  
  16. FROM Arts IMPORT Assert;
  17.  
  18. FROM PeekNPoke IMPORT
  19.  GetByte,GetWordB,GetLongB,PutByte,PutWordB,PutLongB;
  20.  
  21. IMPORT
  22.  Heap;
  23.  
  24. PROCEDURE GetAddr(base:ADDRESS; offset:LONGINT):ADDRESS;
  25. BEGIN
  26.  RETURN CAST(ADDRESS,GetLongB(base,offset));
  27. END GetAddr;
  28.  
  29. PROCEDURE PutAddr(base:ADDRESS; offset:LONGINT; addr:ADDRESS);
  30. BEGIN
  31.  PutLongB(base,offset,CAST(LONGCARD,addr));
  32. END PutAddr;
  33.  
  34. PROCEDURE PutName(base:Absolute; offset:LONGINT; name:Name);
  35. VAR
  36.  i:SHORTCARD;
  37. BEGIN
  38.  FOR i:=0 TO nameLen-1 DO
  39.   PutByte(base,LONGINT(i)+offset,SHORTCARD(name[i]));
  40.  END;
  41. END PutName;
  42.  
  43. PROCEDURE GetName(base:Absolute; offset:LONGINT; VAR name:Name);
  44. VAR
  45.  i:SHORTCARD;
  46. BEGIN
  47.  FOR i:=0 TO nameLen-1 DO
  48.   name[i]:=CHAR(GetByte(base,LONGINT(i)+offset));
  49.  END;
  50. END GetName;
  51.  
  52. PROCEDURE Address(mod:Module; mno,eno:SHORTCARD):Absolute;
  53. (* address of entry mno,eno *)
  54. VAR
  55.  imported:Module;
  56. BEGIN
  57.  imported:=importsG(mod,mno);
  58. (*$OverflowChk:=FALSE*)
  59.  RETURN codeG(imported)+entriesG(imported,eno);
  60. (*$POP OverflowChk*)
  61. END Address;
  62.  
  63. PROCEDURE MakeAbsolute(mod:Module; base:Absolute; entry:Entry);
  64. (*
  65.  Replace an long word consisting of module number an entry number
  66.  as bytes at offset 2 and 3 with an absolute 32 bit address stored in
  67.  a big endian fashion at offset 0.
  68. *)
  69. VAR
  70.  adr:LONGINT;
  71.  eno,mno:SHORTCARD;
  72. BEGIN
  73.  mno:=GetByte(base,entry+2); eno:=GetByte(base,entry+3);
  74.  adr:=Address(mod,mno,eno);
  75.  PutLongB(base,entry,CAST(LONGCARD,adr));
  76. END MakeAbsolute;
  77.  
  78. PROCEDURE Fixup(mod:Module; link:CARDINAL);
  79. (* follow fixup chain and insert absolute addresses *)
  80. VAR
  81.  address:Absolute;
  82.  code:CodeBase;
  83.  nxt:OldCardinal;
  84.  entry,next:CARDINAL;
  85.  modno,entno:SHORTCARD;
  86. BEGIN
  87.  code:=codeG(mod);
  88.  WHILE link#0 DO
  89.   (*
  90.    At each link position, the first 16 bit contain a word offset to the
  91.    next link posision. The second 16 bit contain a module and an entry
  92.    number as 2 bytes packed into one word. link indexes words!
  93.   *)
  94.   nxt:=GetWordB(code,2*OldCardinal(link));
  95.   next:=nxt;
  96.   modno:=GetByte(code,2*OldCardinal(link)+2);
  97.   entno:=GetByte(code,2*OldCardinal(link)+3);
  98.   IF modno=255 THEN (* special, indicate the new and sysNew procedures *)
  99.    address:=module255[entno];
  100.   ELSE
  101.    address:=Address(mod,modno,entno); (* Lookup the relocated address *)
  102.   END;
  103.   (*
  104.    Replace the linkage entry by the absoulte 32 bit address, and go to
  105.    the next link position.
  106.   *)
  107.   PutLongB(code,2*OldCardinal(link),address);
  108.   link:=next
  109.  END
  110. END Fixup;
  111.  
  112.  (*
  113.   Type descriptor offsets. The type descriptor looks roughly like this:
  114.  
  115.   Reference=RECORD
  116.    CASE (*relocated*):BOOLEAN OF
  117.    | FALSE: moduleNumber,entryNumber:INTEGER;
  118.    | TRUE: address:ADDRESS;
  119.    END;
  120.   END;
  121.  
  122.   TypeDescriptor=RECORD
  123.    methods:ARRAY OF Reference;
  124.    (*-4*) tag:LONGINT;  (* offset -4, as pointer points to size element *)
  125.    (* 0*) size:LONGCARD; (* pointer points to this element *)
  126.    (* 4*) extensionLevel:INTEGER;
  127.    (* 6*) numberOfMethods:INTEGER;
  128.    (* 8*) moduleAddress:ADDRESS;
  129.    (*12*) reserved:ADDRESS;
  130.    (*16*) baseTypes:ARRAY [0..7] OF Reference;
  131.    (*48*) name:ARRAY [0..23] OF CHAR; (* 0C terminated *)
  132.    (*72*) pointerOffsets:ARRAY OF LONGINT; (* variable length *)
  133.    backPointer:LONGINT; (* relative pointer back to «size» *)
  134.  
  135.   But because the type descriptor is used on the Oberon side too, it is
  136.   manipulated using the known offsets used by the Oberon compiler. An
  137.   overlaying of the above declared structure, would make this program
  138.   also dependent from the Modula compiler.
  139.  
  140.   Note:
  141.    TypeDescriptors need to be aligned on an 8 byte boundary, i.e. tdAdr MOD 8=0.
  142.  *)
  143. CONST
  144.  tagOff=-4; baseTypeOff=40;
  145.  referenceSize=4;
  146.  
  147. PROCEDURE CompleteTypeDescs(mod:Module);
  148. (* completes type descriptors of a module *)
  149. VAR
  150.  address:LONGINT;
  151.  code:CodeBase;
  152.  dataSize:Size;
  153.  i,j:Count;
  154.  extlev,numberOfMethods:INTEGER;
  155.  mno,eno:SHORTCARD;
  156.  relTypeDesc:Entry;
  157.  typeDesc:TypeDescriptor;
  158.  size:Size;
  159. BEGIN
  160.  code:=codeG(mod);
  161.  dataSize:=dataSizeG(mod);
  162.  FOR i:=0 TO nofEntriesG(mod)-1 DO
  163.   relTypeDesc:=entriesG(mod,i);
  164.   IF relTypeDesc<(-Entry(dataSize)) THEN
  165.    (*
  166.     The entry can only be a type descriptor, if it is located in
  167.     the const area, i.e. the entry offsett is less than the data
  168.     size.
  169.    *)
  170.    typeDesc:=code+relTypeDesc;
  171.    Assert(typeDesc=constG(mod)+constSizeG(mod)+dataSizeG(mod)+relTypeDesc,NIL);
  172.  
  173.    tdTagP(typeDesc,1); (* set mark bit *)
  174.  
  175.    (*
  176.     Extend size by a long word, and realligne on a 16 byte boundary.
  177.    *)
  178.    size:=tdSizeG(typeDesc);
  179.    size:=(((size+4)+15) DIV 16)*16;
  180.    tdSizeP(typeDesc,size);
  181.  
  182.    (*
  183.     Store the module base in the type descriptor
  184.    *)
  185.    tdModuleP(typeDesc,mod);
  186.  
  187.    (*
  188.     Read the extension level.
  189.    *)
  190.    FOR j:=0 TO tdExtensionLevelG(typeDesc) DO
  191.     (*
  192.      Fill base type table by transforming every entry from the
  193.      mno,eno form to its real address.
  194.     *)
  195.  
  196.     MakeAbsolute(mod,typeDesc,baseTypeOff+(j*referenceSize));
  197.    END;
  198.  
  199.    FOR j:=1 TO tdNumberOfMethodsG(typeDesc) DO
  200.     (*
  201.      Fill method table by transforming every entry from the
  202.      mno,eno form to its real address.
  203.  
  204.      Note: tag is the first item after the method table.
  205.     *)
  206.     MakeAbsolute(mod,typeDesc,tagOff-(j*referenceSize));
  207.    END;
  208.   END;
  209.  END;
  210. END CompleteTypeDescs;
  211.  
  212. PROCEDURE tdTagP(td:TypeDescriptor; tag:Tag);
  213. BEGIN PutLongB(td,-4,tag); END tdTagP;
  214.  
  215. PROCEDURE tdSizeG(td:TypeDescriptor):Size;
  216. BEGIN RETURN GetLongB(td,0); END tdSizeG;
  217.  
  218. PROCEDURE tdSizeP(td:TypeDescriptor; size:Size);
  219. BEGIN PutLongB(td,0,size); END tdSizeP;
  220.  
  221. PROCEDURE tdExtensionLevelG(td:TypeDescriptor):Count;
  222. BEGIN RETURN GetWordB(td,4); END tdExtensionLevelG;
  223.  
  224. PROCEDURE tdNumberOfMethodsG(td:TypeDescriptor):Count;
  225. BEGIN RETURN GetWordB(td,6); END tdNumberOfMethodsG;
  226.  
  227. PROCEDURE tdModuleP(td:TypeDescriptor; mod:Module);
  228. BEGIN PutAddr(td,8,mod); END tdModuleP;
  229.  
  230.  
  231.  (*
  232.   Module header offsets. The module descripter looks roughly like this:
  233.  
  234.   Name=ARRAY [0..NameLen-1] OF CHAR;
  235.   Command=RECORD
  236.    name:Name;
  237.    entry:LONGCARD;
  238.   END;
  239.   Module=POINTER TO ModuleDesc;
  240.   ModuleDesc=RECORD
  241.    (*-4*) tag:LONGINT; (* offset -4, as pointer points to next element *)
  242.    (* 0*) next:Module; (* pointer points to this item *)
  243.    (* 4*) nofEntries:INTEGER;
  244.    (* 6*) nofCommands:INTEGER;
  245.    (* 8*) nofPtrs:INTEGER;
  246.    (*10*) nofImports:INTEGER;
  247.    (*12*) refCnt:INTEGER;
  248.    (*14*) constSize:LONGINT;
  249.    (*18*) dataSize:LONGINT;
  250.    (*22*) codeSize:LONGINT;
  251.    (*26*) refSize:LONGINT;
  252.    (*30*) key:LONGINT;
  253.    (*34*) name:ARRAY [0..23] OF CHAR;
  254.    (*58*) entry:ADDRESS;
  255.    (*62*) command:ADDRESS;
  256.    (*66*) ptr:ADDRESS;
  257.    (*70*) import:ADDRESS;
  258.    (*74*) const:ADDRESS;
  259.    (*78*) data:ADDRESS;
  260.    (*82*) code:ADDRESS;
  261.    (*86*) ref:ADDRESS;
  262.    (*90*) entries:ARRAY OF LONGCARD; (* nofEntries *)
  263.    commands:ARRAY OF Command; (* nofCommands *)
  264.    pointerOffsets:ARRAY OF LONGINT; (* nofPtrs *)
  265.    imports:ARRAY OF Module; (* nofImports+1 *)
  266.    constants:ARRAY OF SHORTCARD; (* constSize *)
  267.    data:ARRAY OF SHORTCARD; (* dataSize *)
  268.    code:ARRAY OF SHORTCARD; (* codeSize *)
  269.    references:ARRAY OF SHORTCARD; (* refSize *)
  270.   END;
  271.  
  272.   Again we won't alias a Modula-2 declaration to it, but use the offsets
  273.   declared below, which conform to the allocation strategy of the Oberon
  274.   compiler.
  275.  
  276.   Note:
  277.    The constants, data and code area have to be aligned on an 8 byte boundary,
  278.    to satisfy the alignement condition for type descriptors.
  279.  *)
  280.  
  281. PROCEDURE tagP(mod:Module; tag:Tag);
  282. BEGIN PutLongB(mod,-4,tag); END tagP;
  283.  
  284. PROCEDURE nextG(mod:Module):Module;
  285. BEGIN RETURN GetAddr(mod,0); END nextG;
  286.  
  287. PROCEDURE nextP(mod:Module; next:Module);
  288. BEGIN PutAddr(mod,0,next); END nextP;
  289.  
  290. PROCEDURE nofEntriesG(mod:Module):Count;
  291. BEGIN RETURN GetWordB(mod,4); END nofEntriesG;
  292.  
  293. PROCEDURE nofEntriesP(mod:Module; count:Count);
  294. BEGIN PutWordB(mod,4,count); END nofEntriesP;
  295.  
  296. PROCEDURE nofCommandsG(mod:Module):Count;
  297. BEGIN RETURN GetWordB(mod,6); END nofCommandsG;
  298.  
  299. PROCEDURE nofCommandsP(mod:Module; count:Count);
  300. BEGIN PutWordB(mod,6,count); END nofCommandsP;
  301.  
  302. PROCEDURE nofPointersG(mod:Module):Count;
  303. BEGIN RETURN GetWordB(mod,8); END nofPointersG;
  304.  
  305. PROCEDURE nofPointersP(mod:Module; count:Count);
  306. BEGIN PutWordB(mod,8,count); END nofPointersP;
  307.  
  308. PROCEDURE nofImportsG(mod:Module):Count;
  309. BEGIN RETURN GetWordB(mod,10); END nofImportsG;
  310.  
  311. PROCEDURE nofImportsP(mod:Module; count:Count);
  312. BEGIN PutWordB(mod,10,count); END nofImportsP;
  313.  
  314. PROCEDURE refCntG(mod:Module):Count;
  315. BEGIN RETURN GetWordB(mod,12); END refCntG;
  316.  
  317. PROCEDURE refCntP(mod:Module; refCnt:Count);
  318. BEGIN PutWordB(mod,12,refCnt); END refCntP;
  319.  
  320. PROCEDURE constSizeG(mod:Module):Size;
  321. BEGIN RETURN GetLongB(mod,14); END constSizeG;
  322.  
  323. PROCEDURE constSizeP(mod:Module; size:Size);
  324. BEGIN PutLongB(mod,14,size); END constSizeP;
  325.  
  326. PROCEDURE dataSizeG(mod:Module):Size;
  327. BEGIN RETURN GetLongB(mod,18); END dataSizeG;
  328.  
  329. PROCEDURE dataSizeP(mod:Module; size:Size);
  330. BEGIN PutLongB(mod,18,size); END dataSizeP;
  331.  
  332. PROCEDURE codeSizeG(mod:Module):Size;
  333. BEGIN RETURN GetLongB(mod,22); END codeSizeG;
  334.  
  335. PROCEDURE codeSizeP(mod:Module; size:Size);
  336. BEGIN PutLongB(mod,22,size); END codeSizeP;
  337.  
  338. PROCEDURE refSizeG(mod:Module):Size;
  339. BEGIN RETURN GetLongB(mod,26); END refSizeG;
  340.  
  341. PROCEDURE refSizeP(mod:Module; size:Size);
  342. BEGIN PutLongB(mod,26,size); END refSizeP;
  343.  
  344. PROCEDURE keyG(mod:Module):Key;
  345. BEGIN RETURN GetLongB(mod,30); END keyG;
  346.  
  347. PROCEDURE keyP(mod:Module; key:Key);
  348. BEGIN PutLongB(mod,30,key); END keyP;
  349.  
  350. PROCEDURE nameG(mod:Module; VAR name:Name);
  351. BEGIN
  352.  GetName(mod,34,name);
  353. END nameG;
  354.  
  355. PROCEDURE nameP(mod:Module; name:Name);
  356. BEGIN
  357.  PutName(mod,34,name);
  358. END nameP;
  359.  
  360. PROCEDURE entryG(mod:Module):EntryBase;
  361. BEGIN RETURN GetAddr(mod,58); END entryG;
  362.  
  363. PROCEDURE entryP(mod:Module; entry:EntryBase);
  364. BEGIN PutAddr(mod,58,entry); END entryP;
  365.  
  366. PROCEDURE commandG(mod:Module):CommandBase;
  367. BEGIN RETURN GetAddr(mod,62); END commandG;
  368.  
  369. PROCEDURE commandP(mod:Module; command:CommandBase);
  370. BEGIN PutAddr(mod,62,command); END commandP;
  371.  
  372. PROCEDURE pointerG(mod:Module):PointerBase;
  373. BEGIN RETURN GetAddr(mod,66); END pointerG;
  374.  
  375. PROCEDURE pointerP(mod:Module; pointer:PointerBase);
  376. BEGIN PutAddr(mod,66,pointer); END pointerP;
  377.  
  378. PROCEDURE importG(mod:Module):ImportBase;
  379. BEGIN RETURN GetAddr(mod,70); END importG;
  380.  
  381. PROCEDURE importP(mod:Module; import:ImportBase);
  382. BEGIN PutAddr(mod,70,import); END importP;
  383.  
  384. PROCEDURE constG(mod:Module):ConstBase;
  385. BEGIN RETURN GetAddr(mod,74); END constG;
  386.  
  387. PROCEDURE constP(mod:Module; const:ConstBase);
  388. BEGIN PutAddr(mod,74,const); END constP;
  389.  
  390. PROCEDURE dataG(mod:Module):DataBase;
  391. BEGIN RETURN GetAddr(mod,78); END dataG;
  392.  
  393. PROCEDURE dataP(mod:Module; data:DataBase);
  394. BEGIN PutAddr(mod,78,data); END dataP;
  395.  
  396. PROCEDURE codeG(mod:Module):CodeBase;
  397. BEGIN RETURN GetAddr(mod,82); END codeG;
  398.  
  399. PROCEDURE codeP(mod:Module; code:CodeBase);
  400. BEGIN PutAddr(mod,82,code); END codeP;
  401.  
  402. PROCEDURE refG(mod:Module):RefBase;
  403. BEGIN RETURN GetAddr(mod,86); END refG;
  404.  
  405. PROCEDURE refP(mod:Module; ref:RefBase);
  406. BEGIN PutAddr(mod,86,ref); END refP;
  407.  
  408. PROCEDURE entriesG(mod:Module; index:Index):Entry;
  409. BEGIN RETURN GetAddr(entryG(mod),index*4); END entriesG;
  410.  
  411. PROCEDURE commandsEntryG(mod:Module; index:Index):Entry;
  412. BEGIN RETURN GetAddr(commandG(mod),index*(nameLen+4)+24); END commandsEntryG;
  413.  
  414. PROCEDURE commandsEntryP(mod:Module; index:Index; entry:Entry);
  415. BEGIN PutAddr(commandG(mod),index*(nameLen+4)+24,entry); END commandsEntryP;
  416.  
  417. PROCEDURE commandsNameG(mod:Module; index:Index; VAR name:Name);
  418. BEGIN GetName(commandG(mod),index*(nameLen+4),name); END commandsNameG;
  419.  
  420. PROCEDURE commandsNameP(mod:Module; index:Index; name:Name);
  421. BEGIN PutName(commandG(mod),index*(nameLen+4),name); END commandsNameP;
  422.  
  423. PROCEDURE importsG(mod:Module; index:Index):Module;
  424. BEGIN RETURN GetAddr(importG(mod),index*4); END importsG;
  425.  
  426. PROCEDURE importsP(mod:Module; index:Index; module:Module);
  427. BEGIN PutAddr(importG(mod),index*4,module); END importsP;
  428.  
  429. PROCEDURE SetupPointers(mod:Module);
  430. VAR
  431.  constAdr:Absolute;
  432.  dataStart:Absolute;
  433. BEGIN
  434.  entryP(mod,mod+descSizeAligned);
  435.  commandP(mod,entryG(mod)+4*nofEntriesG(mod));
  436.  pointerP(mod,commandG(mod)+(nameLen+4)*nofCommandsG(mod));
  437.  importP(mod,pointerG(mod)+4*nofPointersG(mod));
  438.  
  439.  constAdr:=importG(mod)+4*(nofImportsG(mod)+1);
  440.  constAdr:=((constAdr+7) DIV 8)*8; (* align on 8 byte boundary *)
  441.  
  442.  constP(mod,constAdr);
  443.  
  444.  dataStart:=constG(mod)+constSizeG(mod);
  445.  codeP(mod,dataStart+dataSizeG(mod));
  446.  dataP(mod,codeG(mod));       (* use same pointer, but with negative offsets *)
  447.  
  448.  refP(mod,codeG(mod)+codeSizeG(mod));
  449. END SetupPointers;
  450.  
  451. PROCEDURE EqualName(mod:Module; name:ARRAY OF CHAR):BOOLEAN;
  452. VAR
  453.  ch:CHAR;
  454.  i:INTEGER;
  455. BEGIN
  456.  i:=0;
  457.  LOOP
  458.   IF i>=nameLen THEN RETURN (i>HIGH(name)) OR (name[i]=0C); END;
  459.   ch:=CHAR(GetByte(mod,34+i));
  460.   IF i>HIGH(name) THEN RETURN ch=0C; END;
  461.   IF ch#name[i] THEN RETURN FALSE; END;
  462.   IF ch=0C THEN RETURN TRUE; END;
  463.   INC(i);
  464.  END;
  465. END EqualName;
  466.  
  467. PROCEDURE AllocateMod(nofEntries:Count; nofCommands:Count; nofPtrs:Count; nofImports:Count; constSize:Size; dataSize:Size; codeSize:Size; refSize:Size):Module;
  468. VAR
  469.  m:ADDRESS;
  470.  size:Size;
  471. BEGIN
  472.  size:=
  473.   descSizeAligned         (* Size of Module-descriptor *)
  474.   +4*nofEntries           (* The entry table *)
  475.   +(nameLen+4)*nofCommands  (* The command table *)
  476.   +4*nofPtrs              (* The table with the offsets of the gloabl pointer variables *)
  477.   +4*(nofImports+1)       (* References to imported modules *)
  478.   +constSize              (* The constants of this module *)
  479.   +dataSize               (* The global data of this module *)
  480.   +codeSize               (* The code of this module *)
  481.   +refSize;               (* The reference information needed by Oberons trap handler *)
  482.  Heap.Allocate(m,size+7+4);
  483.  (*
  484.   Allocate 4 bytes more for tag field at offset -4, and another 7 bytes
  485.   more, so that we can adjust the const space to an 8 byte boundary.
  486.  *)
  487.  RETURN Module(m);
  488. END AllocateMod;
  489.  
  490. PROCEDURE DeallocateMod(mod:Module);
  491. VAR
  492.  m:ADDRESS;
  493. BEGIN
  494.  m:=mod;
  495.  Heap.Deallocate(m);
  496. END DeallocateMod;
  497.  
  498. END OLoadData.
  499.